#' @include control_step.R

NULL

#' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Helper functions that are used internally for the STEP calculations.

#'

#' @inheritParams argument_convention

#'

#' @name h_step

NULL

#' @describeIn h_step creates the windows for STEP, based on the control settings

#'   provided.

#'

#' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).

#' @param control (named `list`)\cr output from `control_step()`.

#'

#' @return

#' * `h_step_window()` returns a list containing the window-selection matrix `sel`

#'   and the interval information matrix `interval`.

#'

#' @export

h_step_window <- function(x,

                          control = control_step()) {

    # Create windows according to percentile cutoffs.

      )

    }

    # Center is the middle point of the percentile window.

  } else {

    # Create windows according to cutoffs.

      )

    }

    # Center is the same as the point for predicting.

  }

}

#' @describeIn h_step calculates the estimated treatment effect estimate

#'   on the linear predictor scale and corresponding standard error from a STEP `model` fitted

#'   on `data` given `variables` specification, for a single biomarker value `x`.

#'   This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds

#'   ratio estimates.

#' @param model the regression model object.

#'

#' @return

#' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.

#'

#' @export

h_step_trt_effect <- function(data,

                              model,

                              variables,

                              x) {

  # Note: It is important to use the coef subset from matrix, otherwise intercept and

  # strata are included for coxph() models.

  )

}

#' @describeIn h_step builds the model formula used in survival STEP calculations.

#'

#' @return

#' * `h_step_survival_formula()` returns a model formula.

#'

#' @export

h_step_survival_formula <- function(variables,

                                    control = control_step()) {

  }

  }

  }

}

#' @describeIn h_step estimates the model with `formula` built based on

#'   `variables` in `data` for a given `subset` and `control` parameters for the

#'   Cox regression.

#' @param formula (`formula`)\cr the regression model formula.

#' @param subset (`logical`)\cr subset vector.

#'

#' @return

#' * `h_step_survival_est()` returns a matrix of number of observations `n`,

#'   `events`, log hazard ratio estimates `loghr`, standard error `se`,

#'   and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is

#'   included for each biomarker value in `x`.

#'

#' @export

h_step_survival_est <- function(formula,

                                data,

                                variables,

                                x,

                                subset = rep(TRUE, nrow(data)),

                                control = control_coxph()) {

  # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.

        )

      },

      }

    ),

    }

  )

    ))

  }

  # Produce a matrix with one row per `x` and columns `est` and `se`.

  ))

  )

}

#' @describeIn h_step builds the model formula used in response STEP calculations.

#'

#' @return

#' * `h_step_rsp_formula()` returns a model formula.

#'

#' @export

h_step_rsp_formula <- function(variables,

                               control = c(control_step(), control_logistic())) {

  )

  }

  }

    } else {

    }

  }

}

#' @describeIn h_step estimates the model with `formula` built based on

#'   `variables` in `data` for a given `subset` and `control` parameters for the

#'   logistic regression.

#' @param formula (`formula`)\cr the regression model formula.

#' @param subset (`logical`)\cr subset vector.

#'

#' @return

#' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds

#'   ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds

#'   `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.

#'

#' @export

h_step_rsp_est <- function(formula,

                           data,

                           variables,

                           x,

                           subset = rep(TRUE, nrow(data)),

                           control = control_logistic()) {

  # Note: `subset` in `glm` needs to be an expression referring to `data` variables.

          )

        } else {

          # clogit needs coxph and strata imported

          )

        }

      },

      }

    ),

    }

  )

    ))

  }

  # Produce a matrix with one row per `x` and columns `est` and `se`.

  ))

  )

}

#' Occurrence Table Pruning

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Family of constructor and condition functions to flexibly prune occurrence tables.

#' The condition functions always return whether the row result is higher than the threshold.

#' Since they are of class [CombinationFunction()] they can be logically combined with other condition

#' functions.

#'

#' @note Since most table specifications are worded positively, we name our constructor and condition

#'   functions positively, too. However, note that the result of [keep_rows()] says what

#'   should be pruned, to conform with the [rtables::prune_table()] interface.

#'

#' @examples

#' \dontrun{

#' tab <- basic_table() %>%

#'   split_cols_by("ARM") %>%

#'   split_rows_by("RACE") %>%

#'   split_rows_by("STRATA1") %>%

#'   summarize_row_groups() %>%

#'   summarize_vars("COUNTRY", .stats = "count_fraction") %>%

#'   build_table(DM)

#' }

#'

#' @name prune_occurrences

NULL

#' @describeIn prune_occurrences Constructor for creating pruning functions based on

#'   a row condition function. This removes all analysis rows (`TableRow`) that should be

#'   pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no

#'   children left.

#'

#' @param row_condition (`CombinationFunction`)\cr condition function which works on individual

#'   analysis rows and flags whether these should be kept in the pruned table.

#'

#' @return

#' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]

#'   to prune an `rtables` table.

#'

#' @export

#'

#' @examples

#' \dontrun{

#' # `keep_rows`

#' is_non_empty <- !CombinationFunction(all_zero_or_na)

#' prune_table(tab, keep_rows(is_non_empty))

#' }

keep_rows <- function(row_condition) {

    }

  }

}

#' @describeIn prune_occurrences Constructor for creating pruning functions based on

#'   a condition for the (first) content row in leaf tables. This removes all leaf tables where

#'   the first content row does not fulfill the condition. It does not check individual rows.

#'   It then proceeds recursively by removing the sub tree if there are no children left.

#' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual

#'   first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.

#'

#' @return

#' * `keep_content_rows()` returns a pruning function that checks the condition on the first content

#'   row of leaf tables in the table.

#'

#' @examples

#' # `keep_content_rows`

#' # Internal function - has_count_in_cols

#' \dontrun{

#' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))

#' prune_table(tab, keep_content_rows(more_than_twenty))

#' }

#'

#' @export

keep_content_rows <- function(content_row_condition) {

    }

    }

  }

}

#' @describeIn prune_occurrences Constructor for creating condition functions on total counts in

#'  the specified columns.

#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to

#'   keep the row.

#' @param ... arguments for row or column access, see [`rtables_access`]: either

#'   `col_names` (`character`) including the names of the columns which should be used,

#'   or alternatively `col_indices` (`integer`) giving the indices directly instead.

#'

#' @return

#' * `has_count_in_cols()` returns a condition function that sums the counts in the specified

#'   column.

#'

#' @examples

#' # Internal function - has_count_in_cols

#' \dontrun{

#' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))

#' prune_table(tab, keep_rows(more_than_one))

#' }

#'

#' @keywords internal

has_count_in_cols <- function(atleast, ...) {

  })

}

#' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in

#'  the specified columns satisfying a threshold.

#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to

#'   keep the row.

#'

#' @return

#' * `has_count_in_any_col()` returns a condition function that compares the counts in the

#'   specified columns with the threshold.

#'

#' @export

#'

#' @examples

#' \dontrun{

#' # `has_count_in_any_col`

#' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))

#' prune_table(tab, keep_rows(any_more_than_one))

#' }

has_count_in_any_col <- function(atleast, ...) {

  })

}

#' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in

#'  the specified columns.

#'

#' @return

#' * `has_fraction_in_cols()` returns a condition function that sums the counts in the

#'   specified column, and computes the fraction by dividing by the total column counts.

#'

#' @export

#'

#' @examples

#' \dontrun{

#' # `has_fraction_in_cols`

#' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))

#' prune_table(tab, keep_rows(more_than_five_percent))

#' }

has_fraction_in_cols <- function(atleast, ...) {

  })

}

#' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in

#'  the specified columns.

#'

#' @return

#' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions

#'  in the specified columns and checks whether any of them fulfill the threshold.

#'

#' @export

#'

#' @examples

#' \dontrun{

#' # `has_fraction_in_any_col`

#' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))

#' prune_table(tab, keep_rows(more_than_five_percent))

#' }

has_fraction_in_any_col <- function(atleast, ...) {

  })

}

#' @describeIn prune_occurrences Constructor for creating condition function that checks the difference

#'   between the fractions reported in each specified column.

#'

#' @return

#' * `has_fractions_difference()` returns a condition function that extracts the fractions of each

#'   specified column, and computes the difference of the minimum and maximum.

#'

#' @export

#'

#' @examples

#' \dontrun{

#' # `has_fractions_difference`

#' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))

#' prune_table(tab, keep_rows(more_than_five_percent_diff))

#' }

has_fractions_difference <- function(atleast, ...) {

  })

}

#' @describeIn prune_occurrences Constructor for creating condition function that checks the difference

#'   between the counts reported in each specified column.

#'

#' @return

#' * `has_counts_difference()` returns a condition function that extracts the counts of each

#'   specified column, and computes the difference of the minimum and maximum.

#'

#' @examples

#' # Internal function - has_counts_difference

#' \dontrun{

#' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))

#' prune_table(tab, keep_rows(more_than_one_diff))

#' }

#'

#' @keywords internal

has_counts_difference <- function(atleast, ...) {

  })

}

#' Missing Data

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Substitute missing data with a string or factor level.

#'

#' @param x factor or character vector

#' @param label character string that missing data should be replaced with

#'

#' @return `x` with any `NA` values substituted by `label`.

#'

#' @export

#'

#' @examples

#' explicit_na(c(NA, "a", "b"))

#' is.na(explicit_na(c(NA, "a", "b")))

#'

#' explicit_na(factor(c(NA, "a", "b")))

#' is.na(explicit_na(factor(c(NA, "a", "b"))))

#'

#' explicit_na(sas_na(c("a", "")))

explicit_na <- function(x, label = "<Missing>") {

  } else {

  }

}

#' Convert Strings to `NA`

#'

#' @description `r lifecycle::badge("stable")`

#'

#' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to

#' convert these values to \code{NA}s.

#'

#' @inheritParams explicit_na

#' @param empty boolean if true empty strings get replaced by \code{NA}

#' @param whitespaces boolean, if true then strings made from whitespaces only get replaced with \code{NA}

#'

#' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of

#'   `empty` and `whitespaces`.

#'

#' @export

#'

#' @examples

#' sas_na(c("1", "", " ", "   ", "b"))

#' sas_na(factor(c("", " ", "b")))

#'

#' is.na(sas_na(c("1", "", " ", "   ", "b")))

sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {

  } else {

  }

}

#' Difference Test for Two Proportions

#'

#' @description `r lifecycle::badge("stable")`

#'

#' Various tests were implemented to test the difference between two

#' proportions.

#'

#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response

#'   (`TRUE`/`FALSE`) in columns.

#'

#' @seealso [h_prop_diff_test]

#'

#' @name prop_diff_test

NULL

#' @describeIn prop_diff_test Statistics function which tests the difference

#'  between two proportions.

#'

#' @inheritParams argument_convention

#' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used

#'   to calculate the p-value.

#'

#' @return

#' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`

#'   describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.

#'

#' @examples

#'

#' # Statistics function

#' dta <- data.frame(

#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),

#'   grp = factor(rep(c("A", "B"), each = 50)),

#'   strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))

#' )

#'

#' # Internal function - s_test_proportion_diff

#' \dontrun{

#' s_test_proportion_diff(

#'   df = subset(dta, grp == "A"),

#'   .var = "rsp",

#'   .ref_group = subset(dta, grp == "B"),

#'   .in_ref_col = FALSE,

#'   variables = list(strata = "strat"),

#'   method = "cmh"

#' )

#' }

#'

#' @keywords internal

s_test_proportion_diff <- function(df,

                                   .var,

                                   .ref_group,

                                   .in_ref_col,

                                   variables = list(strata = NULL),

                                   method = c("chisq", "schouten", "fisher", "cmh")) {

    )

    )

    }

    )

    )

  }

}

#' Description of the Difference Test Between Two Proportions

#'

#' @description `r lifecycle::badge("stable")`

#'

#' This is an auxiliary function that describes the analysis in

#' `s_test_proportion_diff`.

#'

#' @inheritParams s_test_proportion_diff

#'

#' @return `string` describing the test from which the p-value is derived.

#'

#' @export

d_test_proportion_diff <- function(method) {

  )

}

#' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.

#'

#' @return

#' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].

#'

#' @examples

#' # Internal function - a_test_proportion_diff

#' \dontrun{

#' a_test_proportion_diff(

#'   df = subset(dta, grp == "A"),

#'   .var = "rsp",

#'   .ref_group = subset(dta, grp == "B"),

#'   .in_ref_col = FALSE,

#'   variables = list(strata = "strat"),

#'   method = "cmh"

#' )

#' }

#'

#' @keywords internal

a_test_proportion_diff <- make_afun(

  s_test_proportion_diff,

  .formats = c(pval = "x.xxxx | (<0.0001)"),

  .indent_mods = c(pval = 1L)

)

#' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments

#'   and additional format arguments. This function is a wrapper for [rtables::analyze()].

#'

#' @param ... other arguments are passed to [s_test_proportion_diff()].

#' @inheritParams argument_convention

#'

#' @return

#' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,

#'   or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing

#'   the statistics from `s_test_proportion_diff()` to the table layout.

#'

#' @export

#'

#' @examples

#' # With `rtables` pipelines.

#' l <- basic_table() %>%

#'   split_cols_by(var = "grp", ref_group = "B") %>%

#'   test_proportion_diff(

#'     vars = "rsp",

#'     method = "cmh", variables = list(strata = "strat")

#'   )

#'

#' build_table(l, df = dta)

test_proportion_diff <- function(lyt,

                                 vars,

                                 ...,

                                 var_labels = vars,

                                 show_labels = "hidden",

                                 table_names = vars,

                                 .stats = NULL,

                                 .formats = NULL,

                                 .labels = NULL,

                                 .indent_mods = NULL) {

  )

  )

}

#' Helper Functions to Test Proportion Differences

#'

#' Helper functions to implement various tests on the difference between two

#' proportions.

#'

#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response

#'   (`TRUE`/`FALSE`) in columns.

#'

#' @return A p-value.

#'

#' @seealso [prop_diff_test())] for implementation of these helper functions.

#'

#' @name h_prop_diff_test

NULL

#' @describeIn h_prop_diff_test performs Chi-Squared test.

#'   Internally calls [stats::prop.test()].

#'

#' @examples

#' # Non-stratified proportion difference test

#'

#' ## Data

#' A <- 20

#' B <- 20

#' set.seed(1)

#' rsp <- c(

#'   sample(c(TRUE, FALSE), size = A, prob = c(3 / 4, 1 / 4), replace = TRUE),

#'   sample(c(TRUE, FALSE), size = A, prob = c(1 / 2, 1 / 2), replace = TRUE)

#' )

#' grp <- c(rep("A", A), rep("B", B))

#' tbl <- table(grp, rsp)

#'

#' ## Chi-Squared test

#' # Internal function - prop_chisq

#' \dontrun{

#' prop_chisq(tbl)

#' }

#'

#' @keywords internal

prop_chisq <- function(tbl) {

  }

}

#' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test.

#'   Internally calls [stats::mantelhaen.test()]. Note that strata with less than two observations

#'   are automatically discarded.

#'

#' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response

#'   (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.

#'

#' @examples

#' # Stratified proportion difference test

#'

#' ## Data

#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)

#' grp <- factor(rep(c("A", "B"), each = 50))

#' strata <- factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))

#' tbl <- table(grp, rsp, strata)

#'

#' ## Cochran-Mantel-Haenszel test

#' # Internal function - prop_cmh

#' \dontrun{

#' prop_cmh(tbl)

#' }

#'

#' @keywords internal

prop_cmh <- function(ary) {

  }

}

#' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten

#'   correction.

#'

#' @seealso For information on the Schouten correction (Schouten, 1980),

#'   visit https://onlinelibrary.wiley.com/doi/abs/10.1002/bimj.4710220305.

#'

#' @examples

#' ## Chi-Squared test + Schouten correction.

#' # Internal function - prop_schouten

#' \dontrun{

#' prop_schouten(tbl)

#' }

#'

#' @keywords internal

prop_schouten <- function(tbl) {

  }

}

#' @describeIn h_prop_diff_test performs the Fisher's exact test.

#'   Internally calls [stats::fisher.test()].

#'

#' @examples

#' ## Fisher's exact test

#' # Internal function - prop_fisher

#' \dontrun{

#' prop_fisher(tbl)

#' }

#'

#' @keywords internal

prop_fisher <- function(tbl) {

}

#' Confidence Intervals for a Difference of Binomials

#'

#' @description `r lifecycle::badge("experimental")`

#'

#' Several confidence intervals for the difference between proportions.

#'

#' @param grp (`factor`)\cr vector assigning observations to one out of two groups

#'   (e.g. reference and treatment group).

#'

#' @name desctools_binom

NULL

#' Recycle List of Parameters

#'

#' This function recycles all supplied elements to the maximal dimension.

#'

#' @param ... (`any`)\cr Elements to recycle.

#'

#' @return A `list`.

#'

#' @keywords internal

#' @noRd

h_recycle <- function(...) {

}

#' @describeIn desctools_binom Several confidence intervals for the difference between proportions.

#'

#' @return A `matrix` of 3 values:

#'   * `est`: estimate of proportion difference.

#'   * `lwr.ci`: estimate of lower end of the confidence interval.

#'   * `upr.ci`: estimate of upper end of the confidence interval.

#'

#' @examples

#' # Internal function - desctools_binom

#' \dontrun{

#' set.seed(2)

#' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)

#' grp <- factor(c(rep("A", 10), rep("B", 10)))

#' tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))

#' desctools_binom(

#'   tbl[1], sum(tbl[1], tbl[3]), tbl[2], sum(tbl[2], tbl[4]),

#'   conf.level = 0.90, method = "waldcc"

#' )

#' }

#'

#' @keywords internal

desctools_binom <- function(x1, n1, x2, n2, conf.level = 0.95, sides = c( # nolint

                              "two.sided",

                              "left", "right"

                            ), method = c(

                              "ac", "wald", "waldcc", "score",

                              "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"

                            )) {

  }

  }

    }

      },

      },

      },

      },

        )

        )

      },

        )

        )

      },

          } else {

          }

        }

          )

        }

      },

      },

      },

            }

            } else {

            }

          }

        }

          } else {

          }

        }

      },

      },

      },

      },

    )

    )

    }

  }

  )

    )

  }))

  } else {

  } else {

  } else {

  } else {

}

#' @describeIn desctools_binom Compute confidence intervals for binomial proportions.

#'

#' @param x (`count`)\cr number of successes

#' @param n (`count`)\cr number of trials

#' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.

#' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of "two-sided" (default),

#'   "left", or "right".

#' @param method (`character`)\cr method to use. Can be one out of: "wald", "wilson", "wilsoncc", "agresti-coull",

#'   "jeffreys", "modified wilson", "modified jeffreys", "clopper-pearson", "arcsine", "logit", "witting", "pratt",

#'   "midp", "lik", and "blaker".

#' @return A `matrix` with 3 columns containing:

#'   * `est`: estimate of proportion difference.

#'   * `lwr.ci`: lower end of the confidence interval.

#'   * `upr.ci`: upper end of the confidence interval.

#'

#' @keywords internal

desctools_binomci <- function(x,

                              n,

                              conf.level = 0.95, # nolint

                              sides = c("two.sided", "left", "right"),

                              method = c(

                                "wilson", "wald", "waldcc", "agresti-coull",

                                "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",

                                "clopper-pearson", "arcsine", "logit", "witting", "pratt",

                                "midp", "lik", "blaker"

                              ),

                              rand = 123,

                              tol = 1e-05) {

  }

  }

    }

    }

    }

    }

    }

    )),

    },

    },

    },

    },

    },

      } else {

        )

      }

      } else {

      }

    },

      } else {

      }

      } else {

      }

    },

      } else {

        } else {

          )